home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGMISC
/
FPCDOCS.LZH
/
KERNEL3.SEQ
< prev
next >
Wrap
Text File
|
1988-09-20
|
22KB
|
637 lines
\ KERNEL3.SEQ More kernel stuff
FILES DEFINITIONS
VARIABLE KERNEL3.SEQ
FORTH DEFINITIONS
: >TYPE ( adr len -- )
TUCK PAD SWAP CMOVE PAD SWAP TYPE ;
: .( ( -- ) ASCII ) PARSE >TYPE ; IMMEDIATE
: ( ( -- ) ASCII ) PARSE 2DROP ; IMMEDIATE
CODE TRAVERSE ( addr direction -- addr' )
POP CX POP BX
ADD BX, CX PUSH ES
MOV ES, YSEG
BEGIN
MOV ES: AL, 0 [BX] AND AL, # 128
0= WHILE
ADD BX, CX
REPEAT
POP ES PUSH BX
NEXT END-CODE
CODE DONE? ( n -- f )
POP AX
CMP AX, STATE
0<> IF
MOV END? # 0 WORD
MOV AX, # -1
1PUSH
THEN
PUSH END?
MOV END? # 0 WORD
NEXT
END-CODE
\ : DONE? ( n -- f )
\ STATE @ <> END? @ OR END? OFF ;
: CNHASH ( CFA-YA )
$0FE00 AND FLIP ;
CODE CNSRCH ( CFA YA MAXYA - NFA failf )
pop dx \ maxya
pop bx \ ya
add bx, # 4
pop di \ cfa
mov ds, yseg
HERE cmp dx, bx
U> IF mov ax, 0 [bx]
and ax, # 31
add bx, ax
inc bx
mov ax, 0 [bx]
cmp ax, di \ if they match, then we found it
0= if sub bx, # 2 \ 1 before last chr
begin mov al, 0 [bx] \ test high bit
and al, # 128 \ loop till high set
0= while dec bx \ backup one char
repeat
push bx \ push pointer to chr
mov ax, cs \ restore DS
mov ds, ax
mov ax, # false \ push false flag
1push
then
add bx, # 6 \ step to next header
JMP ROT \ bring HERE around Branch resolution
\ used by IF and THEN
THEN
mov ax, cs mov ds, ax
mov ax, # true
push ax
1push end-code
: N>LINK 2- ;
: L>NAME 2+ ;
: BODY> 3 - ;
: NAME> 1 TRAVERSE 1+ Y@ ;
: LINK> L>NAME NAME> ;
: >BODY 3 + ;
HERE-Y 4 + \ Step from view field to name field
: NO-NAME ;
: >NAME ( cfa - nfa )
DUP CNHASH DUP Y@ SWAP
2+ Y@ ( cfa sya mxya ) CNSRCH
IF DROP (LIT) [ ROT ,-X ] THEN ;
: >LINK >NAME N>LINK ;
: >VIEW >LINK 2- ;
: VIEW> 2+ LINK> ;
COMMENT:
The hash algorithm used is as follows:
((firstchar*2)+secondchar)*2)+count
This seems to provide a good distribution across the 64 threads in
1000 word FORTH vocabulary.
COMMENT;
CODE HASH ( str-addr voc-ptr -- thread )
POP CX POP BX
MOV AX, 1 [BX] \ Get first and second chars
SHL AL, # 1 \ Shift first char left one
ADD AL, AH \ Plus second char
SHL AX, # 1 \ The sum shifted left one again
ADD AL, 0 [BX] \ Plus count byte
AND AX, # #THREADS 1-
SHL AX, # 1 ADD AX, CX
1PUSH END-CODE
CODE (FIND) ( here alf -- cfa flag | here false )
POP BX
LABEL (FIND)1 OR BX, BX
0= IF
SUB AX, AX
1PUSH
THEN
POP CX
PUSH ES
MOV ES, YSEG
MOV DI, CX
BEGIN
MOV ES: AX, 2 [BX]
XOR AX, 0 [DI]
AND AX, # ( 63 ) $7F3F
0= IF
MOV DX, BX
ADD BX, # 2
BEGIN
INC BX INC DI
MOV ES: AL, 0 [BX]
XOR AL, 0 [DI]
0<> UNTIL
AND AL, # 127
0= IF
MOV ES: CX, 1 [BX] \ pick up CFA
MOV BX, DX
MOV ES: AL, 2 [BX]
AND AL, # 64
0<> IF
MOV AX, # 1
ELSE
MOV AX, # -1
THEN
POP ES
PUSH CX
1PUSH
THEN
MOV BX, DX
MOV DI, CX
THEN
MOV ES: BX, 0 [BX]
OR BX, BX
0= UNTIL
POP ES
PUSH CX
SUB AX, AX
1PUSH END-CODE
CODE DROP.CONTEXT.I2*+@DUP ( A1 --- N1 )
ADD SP, # 2
MOV AX, 0 [RP]
ADD AX, 2 [RP]
SHL AX, # 1
MOV BX, # CONTEXT
ADD BX, AX
MOV AX, 0 [BX]
PUSH AX
1PUSH
END-CODE
\ DUP PRIOR @ OVER PRIOR ! =
CODE PRIOR.CHECK ( N1 --- N1 F1 )
POP AX
PUSH AX
MOV BX, PRIOR
MOV PRIOR AX
CMP BX, AX
0<> IF
MOV AX, # FALSE
1PUSH
THEN
MOV AX, # TRUE
1PUSH
END-CODE
CODE OVER.SWAP.HASH.@(FIND)
POP AX
POP BX
PUSH BX
MOV CL, 0 [BX]
MOV BX, 1 [BX]
SHL BL, # 1
ADD BL, BH
SHL BL, # 1
ADD BL, CL
AND BX, # #THREADS 1-
SHL BX, # 1
ADD BX, AX
MOV BX, 0 [BX]
JMP (FIND)1
\ PUSH 0 [BX]
\ NEXT
END-CODE
: FIND ( addr -- cfa flag | addr false )
DUP C@
IF \ PRIOR OFF FALSE #VOCS 0
[ INLINE
MOV PRIOR # 0
MOV AX, # 0
PUSH AX
MOV DX, # #VOCS
2PUSH END-INLINE ]
DO DROP.CONTEXT.I2*+@DUP
IF PRIOR.CHECK
IF DROP FALSE
ELSE OVER.SWAP.HASH.@(FIND)
DUP ?LEAVE
THEN
THEN
LOOP
ELSE DROP END? ON ['] NOOP 1
THEN ;
: DEFINED ( -- here 0 | cfa [ -1 | 1 ] )
BL WORD ?UPPERCASE FIND ;
: STACKUNDER ( --- )
TRUE ABORT" Stack Underflow" ;
: STACKOVER ( --- )
TRUE ABORT" Stack Overflow" ;
: WARNOVER ( --- )
CR ." Running out of CODE memory! " ;
CODE (?STACK) ( --- )
MOV CX, SP
MOV BX, UP
MOV DX, SP0 [BX]
CMP DX, CX
U< IF
MOV AX, # ' STACKUNDER
JMP AX
THEN
MOV DX, DP [BX]
ADD DX, # 80
CMP CX, DX
U< IF
MOV AX, # ' STACKOVER
JMP AX
THEN
ADD DX, # 200
CMP CX, DX
U< IF
MOV AX, # ' WARNOVER
JMP AX
THEN
NEXT END-CODE
DEFER ?STACK ' (?STACK) IS ?STACK
: INTERP ( -- )
BEGIN ?STACK DEFINED
IF EXECUTE
ELSE NUMBER DOUBLE? NOT IF DROP THEN
THEN FALSE DONE?
UNTIL ;
DEFER STATUS ( -- )
DEFER INTERPRET ' INTERP IS INTERPRET
: PRINT ( --- ) PRINTING ON INTERPRET PRINTING OFF ;
: ALLOT ( n -- ) DP +! ;
CODE , ( N --- )
MOV BX, UP
MOV AX, DP [BX]
ADD DP [BX], # 2 WORD
MOV BX, AX
POP CX
MOV 0 [BX], CX
NEXT
END-CODE
CODE C, ( N --- )
MOV BX, UP
MOV AX, DP [BX]
INC DP [BX] WORD
MOV BX, AX
POP CX
MOV 0 [BX], CL
NEXT
END-CODE
: PARAGRAPH ( OFFSET --- PARAGRAPH-INC ) 15 + U16/ ;
: ALIGN ( HERE 1 AND IF BL C, THEN ) ; IMMEDIATE
: EVEN ( DUP 1 AND + ) ; IMMEDIATE
: COMPILE ( -- ) 2R@ R> 2+ >R @L X, ;
: CCOMPILE ( -- ) 2R@ R> 2+ >R @L , ;
: IMMEDIATE ( -- ) 64 ( Precedence bit ) LAST @ YCSET ;
: LITERAL ( n -- ) COMPILE (LIT) X, ; IMMEDIATE
: DLITERAL ( d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE
: ASCII ( -- n ) BL WORD 1+ C@
STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE
: CONTROL ( -- n ) BL WORD 1+ C@ 31 AND
STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE
: CRASH ( -- ) 2R@ 2- @L >NAME CR .ID TRUE
ABORT" <- is an Uninitialized execution vector." ;
: ?MISSING ( f -- )
IF SPACE 'WORD COUNT TYPE
TRUE ABORT" <- What? "
THEN ;
: ' ( -- cfa ) DEFINED 0= ?MISSING ;
: ['] ( -- ) ' [COMPILE] LITERAL ; IMMEDIATE
: [COMPILE] ( -- ) ' X, ; IMMEDIATE
VARIABLE "BUF 80 ALLOT
: XEVEN ( XDP --- XDP_EVEN ) DUP 1 AND + ;
: XALIGN ( --- ) XHERE NIP 1 AND XDP +! ;
: X>"BUF ( --- "BUF )
2R>
2R@ 2DUP C@L 1+ DUP XEVEN R> + >R
?CS: "BUF ROT CMOVEL
2>R "BUF ;
: (") ( -- addr len )
2R@ @L COUNT R> 2+ >R ;
: (X") ( -- addr len )
X>"BUF COUNT ;
: (.") ( -- )
2R@ 2DUP C@L >R 1+ R@ EXTYPE R> 1+ XEVEN R> + >R ;
: ," ( --- )
ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ;
: X," ( -- )
ASCII " PARSE 'WORD PLACE
?CS: 'WORD DUP C@ 1+ >R XHERE R@ CMOVEL
R> XEVEN XDP +! ;
: ." ( -- ) COMPILE (.") X," ; IMMEDIATE
: " ( -- ) COMPILE (") HERE X, ," ; IMMEDIATE
: "" ( -- ) COMPILE (X") X," ; IMMEDIATE
: ">$ ( A1 -- A2 ) DROP 1- ;
VARIABLE FENCE
: TRIM ( faddr voc-addr -- )
#THREADS 0
DO 2DUP @ BEGIN 2DUP U> NOT WHILE Y@ REPEAT
NIP OVER ! 2+
LOOP 2DROP ;
: (FRGET) ( code-addr view-addr -- )
DUP FENCE @ U< ABORT" Below fence" ( ca va )
OVER VOC-LINK @ BEGIN 2DUP U< WHILE @ REPEAT
DUP VOC-LINK ! ( ca va ca pt ) NIP
BEGIN DUP WHILE 2DUP #THREADS 2* - TRIM @ REPEAT
DROP YDP !
DUP 1+ @ OVER >BODY +
(LIT) TRIM DUP 1+ @ SWAP >BODY + = \ If it's a : def
IF DUP >BODY @ XSEG @ + XDPSEG ! \ Set back XHERE too!
XDP OFF
THEN DP ! ;
DEFER WHERE
DEFER ?ERROR
: (ABORT") ( f -- )
X>"BUF COUNT ROT ?ERROR ;
: ABORT" ( -- ) COMPILE (ABORT") X," ; IMMEDIATE
: ABORT ( -- ) TRUE ABORT" " ;
: FORGET ( -- )
BL WORD ?UPPERCASE DUP CURRENT @ HASH @
(FIND) 0= ?MISSING DUP >VIEW (FRGET) ;
: ?CONDITION ( f -- ) NOT ABORT" Conditionals Wrong" ;
: >MARK ( -- addr ) XHERE NIP 0 X, ;
: >RESOLVE ( addr -- ) XHERE -ROT SWAP !L ;
: <MARK ( -- addr ) XHERE NIP ;
: <RESOLVE ( addr -- ) X, ;
: ?>MARK ( -- f addr ) TRUE >MARK ;
: ?>RESOLVE ( f addr -- ) SWAP ?CONDITION >RESOLVE ;
: ?<MARK ( -- f addr ) TRUE <MARK ;
: ?<RESOLVE ( f addr -- ) SWAP ?CONDITION <RESOLVE ;
comment:
LEAVE and ?LEAVE could be non-immediate in this system, but the 83
standard specifies an immediate LEAVE, so they both are for
uniformity.
comment;
: LEAVE COMPILE (LEAVE) ; IMMEDIATE
: ?LEAVE COMPILE (?LEAVE) ; IMMEDIATE
comment:
BEGIN, THEN, DO ?DO, LOOP, +LOOP, UNTIL, AGAIN, REPEAT, IF ELSE,
WHILE: These are the compiling words needed to properly compilethe
Forth Conditional Structures. Each of them is immediate and they
must compile their runtime routines along withwhatever addresses
they need. A modest amount of errorchecking is done. If you want to
rip out the error checking change the ?> and ?< words to > and <
words, andall of the 2DUPs to DUPs and the 2SWAPs to SWAPs. The
rest should stay the same.
DOAGAIN, DOTHEN, DOBEGIN, ?UNTIL & ?WHILE are words that are NOOPs
, or equivalant to ?BRANCH. They are provided to make it easier for
the Decompiler to know where the control structures start and end.
comment;
: BEGIN COMPILE DOBEGIN ?<MARK ; IMMEDIATE
: THEN COMPILE DOTHEN ?>RESOLVE ; IMMEDIATE
: DO COMPILE (DO) ?>MARK ; IMMEDIATE
: ?DO COMPILE (?DO) ?>MARK ; IMMEDIATE
: LOOP COMPILE (LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE
: +LOOP COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE
: UNTIL COMPILE ?UNTIL ?<RESOLVE ; IMMEDIATE
: AGAIN COMPILE DOAGAIN ?<RESOLVE ; IMMEDIATE
: REPEAT 2SWAP COMPILE DOREPEAT ?<RESOLVE ?>RESOLVE ; IMMEDIATE
: IF COMPILE ?BRANCH ?>MARK ; IMMEDIATE
: ELSE COMPILE BRANCH ?>MARK 2SWAP ?>RESOLVE ; IMMEDIATE
: WHILE COMPILE ?WHILE ?>MARK ; IMMEDIATE
: ,VIEW ( -- ) LOADLINE @ Y, ;
: NOHEADROOM ( --- )
TRUE ABORT" Out of HEAD memory!" ;
: NOLISTROOM ( --- )
TRUE ABORT" Out of LIST memory!" ;
CODE SPCHECK ( --- F1 F2 ) \ HEAD AND LIST SPACE CHECK
MOV AX, YDP \ get head DP
SHR AX, # 1 \ convert to ssegment
SHR AX, # 1
SHR AX, # 1
SHR AX, # 1
ADD AX, # 6 \ add 6 segments for headroom
CMP AX, ' #HEADSEGS >BODY \ are we out of space yet
> IF MOV AX, # ' NOHEADROOM
JMP AX
THEN
MOV AX, XDPSEG \ load up LIST segment
SUB AX, XSEG \ convert to size of list so far
ADD AX, # 6 \ add 6 for headroom
CMP AX, ' #LISTSEGS >BODY \ are we out of space yet
> IF MOV AX, # ' NOLISTROOM
JMP AX
THEN
NEXT
END-CODE
: "HEADER ( STR --- )
SPCHECK
WARNING @ IF DUP FIND NIP IF
DUP CR COUNT TYPE ." isn't unique " THEN THEN ( str )
ALIGN YHERE 2- Y@ CNHASH HERE CNHASH <>
IF YHERE HERE CNHASH DUP Y@ ROT MIN SWAP
Y! ( >NAME hash entry )
THEN ,VIEW
YHERE OVER CURRENT @ HASH DUP @ Y, ( link ) ! ( current )
YHERE LAST ! ( remember nfa )
YHERE ?CS: ROT DUP C@ WIDTH @ MIN 1+ >R ( yh cs str )
YHERE YS: R@ CMOVEL ( copy str ) R> YDP +! ALIGN ( nam )
128 SWAP YCSET 128 YHERE 1- YCSET ( delimiter Bits )
HERE Y, ( CFA in header )
YHERE HERE CNHASH 2+ Y! ( valid stopper in next n hash entry)
;
: ,CALL 232 C, 0 HERE 2+ - , ; \ Compiles addr 0000 !!!!
: ,JUMP 233 C, 0 HERE 2+ - , ;
: <HEADER> ( | name --- )
BL WORD ?UPPERCASE "HEADER ;
DEFER HEADER ' <HEADER> IS HEADER
: CREATE ( | name -- ) HEADER ,CALL ;USES >NEXT ,-X
: !CSP ( -- ) SP@ CSP ! ;
: ?CSP ( -- ) SP@ CSP @ <> ABORT" Stack Changed" ;
: HIDE ( -- ) LAST @ DUP N>LINK Y@ SWAP CURRENT @ YHASH ! ;
: REVEAL ( -- ) LAST @ DUP N>LINK SWAP CURRENT @ YHASH ! ;
: (;USES) ( -- )
2R> @L LAST @ NAME> dup>r 3 + - R> 1+ ! ;
: (;CODE) ( -- )
2R> @L LAST @ NAME>
dup>r 232 ( CALL ) R@ C! \ Make a CALL not JUMP
3 + - R> 1+ ! ;
: DOES> ( -- )
COMPILE (;CODE) HERE X, 232 ( CALL ) C,
[ [FORTH] ASSEMBLER DODOES META ] LITERAL
HERE 2+ - , XHERE PARAGRAPH + DUP XDPSEG !
XSEG @ - , XDP OFF ; IMMEDIATE
VOCABULARY ASSEMBLER
DEFER SETASSEM \ Setup for assembly stuff to follow
' NOOP IS SETASSEM
: [ ( -- ) STATE OFF ; IMMEDIATE
: ;USES ( -- ) ?CSP COMPILE (;USES)
[COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE
: ;CODE ( -- ) ?CSP COMPILE (;CODE) HERE X,
[COMPILE] [ REVEAL SETASSEM ; IMMEDIATE
: (]) ( -- )
STATE ON
BEGIN ?STACK DEFINED DUP
IF 0> IF EXECUTE ELSE X, THEN
ELSE DROP NUMBER DOUBLE?
IF [COMPILE] DLITERAL
ELSE DROP [COMPILE] LITERAL THEN
THEN TRUE DONE?
UNTIL ;
DEFER ] ' (]) IS ]
: MAKEDUMMY ( NAME --- )
HEADER ,JUMP
XHERE PARAGRAPH + \ absolute paragraph of new def
DUP XDPSEG ! \ set new XHERE segment
XSEG @ - , \ compile relative paragraph of def
XDP OFF
COMPILE UNNEST
;USES NEST ,-X
: ANEW ( NAME --- )
>IN @ >R DEFINED NIP R@ >IN !
IF FORGET
THEN R> >IN ! MAKEDUMMY ;
\ Add if needed
: (:) ( -- )
!CSP CURRENT @ CONTEXT !
HEADER ,JUMP
XHERE PARAGRAPH +
DUP XDPSEG !
XSEG @ - ,
XDP OFF
HIDE
;USES NEST ,-X
: : ( --- )
(:) ] ;
: ; ( -- )
STATE @ 0= ABORT" Not Compiling!"
?CSP COMPILE UNNEST REVEAL [COMPILE] [ ; IMMEDIATE
: RECURSIVE ( -- ) REVEAL ; IMMEDIATE
: CONSTANT ( n -- ) CREATE , ;USES DOCONSTANT ,-X
: VALUE ( n -- ) CREATE , ;USES DOVALUE ,-X
: VARIABLE ( -- ) CREATE 0 , ;USES >NEXT ,-X
\ not really needed, but pretty.
: DEFER ( -- )
CREATE ['] CRASH , ;USES DODEFER ,-X
DODEFER RESOLVES <DEFER>
: VOCABULARY ( -- ) CREATE #THREADS 0 DO 0 , LOOP
HERE VOC-LINK @ , VOC-LINK !
DOES> CONTEXT ! ;
RESOLVES <VOCABULARY>
: DEFINITIONS ( -- ) CONTEXT @ CURRENT ! ;
: 2CONSTANT CREATE , , ( d# -- )
DOES> 2@ ; ( -- d# ) DROP
: 2VARIABLE 0 0 2CONSTANT ( -- )
DOES> ; ( -- addr ) DROP
: <RUN> ( -- )
STATE @ IF ]
STATE @ NOT
IF INTERPRET THEN
ELSE INTERPRET THEN ;
DEFER RUN ' <RUN> IS RUN
: (?ERROR) ( adr len f -- )
IF ['] <RUN> IS RUN
2>R SP0 @ SP! PRINTING OFF
2R> SPACE TYPE SPACE QUIT
ELSE 2DROP THEN ;
' (?ERROR) IS ?ERROR